Attribute VB_Name = "modROTHook"
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'
' You are entitled to license free distribution of any application
'   that uses this file if you own a copy of the book, or if you
'   have obtained the file from a source approved by the author. You
'   may redistribute this file only with express written permission
'   of the author.
'
' This file depends on:
'   References:
'     VBoostTypes6.olb (VBoost Object Types (6.0))
'     ROTHookTypes.olb (VBoost: ROT Hook Types)
'     VBoost6.Dll (VBoost Object Implementation (6.0)) (optional)
'   Files:
'     VBoost.Bas
'   Minimal VBoost conditionals:
'     VBOOST_INTERNAL = 1 : VBOOST_CUSTOM = 1 : VBOOST_HookQI = 1
'   Conditional Compilation Values:
'     DEBUGROT = 1 'Support the ClearROT function for debugging purposes
'
' This file is discussed in Chapter 10.
'***************************************************************
Option Explicit

'Use private version of CLSIDFromProgID to return long instead of HRESULT
Private Declare Function CLSIDFromProgID Lib "ole32.dll" (ByVal ProgID As Long, rclsid As VBGUID) As Long
Private Declare Function CoLockObjectExternal Lib "ole32.dll" (ByVal pUnk As Long, ByVal fLock As Long, ByVal fLastUnlockReleases As Long) As Long
Private Declare Function RegisterActiveObject Lib "oleaut32.dll" (ByVal pUnk As Long, rclsid As VBGUID, ByVal dwFlags As Long, pdwRegister As Long) As Long
Private Declare Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, Optional ByVal pvReserved As Long = 0) As Long
Private Const ACTIVEOBJECT_WEAK As Long = 1
Private Const MK_S_MONIKERALREADYREGISTERED As Long = &H401E7

Private IID_IUnknown As VBGUID
Private IID_IExternalConnection As VBGUID
Private IID_IROTHook As VBGUID
Private IID_IQIHook As VBGUID

Private Type IROTHookImpl
    pVTableMain As Long
    pVTableQIHook As Long
    pVTableExternal As Long
    pExternal As IExternalConnection
    cRefsExternal As Long
    cConnections As Long
    UnkHook As UnknownHook
    pOuter As IUnknownUnrestricted
    cRefs As Long
    dwRegister As Long
    fLocked As Boolean
    fPassThrough As Boolean
    fAddRefOuter As Boolean
End Type

'The public structure
Public Type ROTHook
    Hook As IROTHook
    Struct As IROTHookImpl
End Type

'These are just copies of IROTHookImpl starting
'at different vtable levels.
Private Type IExtConImpl
    pVTableExternal As Long
    pExternal As IExternalConnection
    cRefsExternal As Long
    cConnections As Long
    UnkHook As UnknownHook
    pOuter As IUnknownUnrestricted
    cRefs As Long
    dwRegister As Long
    fLocked As Boolean
    fPassThrough As Boolean
    fAddRefOuter As Boolean
End Type
Private Type IQIHookImpl
    pVTableQIHook As Long
    pVTableExternal As Long
    pExternal As IExternalConnection
    cRefsExternal As Long
    cConnections As Long
    UnkHook As UnknownHook
    pOuter As IUnknownUnrestricted
    cRefs As Long
    dwRegister As Long
    fLocked As Boolean
    fPassThrough As Boolean
    fAddRefOuter As Boolean
End Type

Private Type ROTHookVTables
    Main(6) As Long
    QIHook(3) As Long 'Don't bother with MapIID entry, it's not ever called
    ExtCon(4) As Long
End Type
Private m_VTables As ROTHookVTables
Private m_pVTableMain As Long
Private m_pVTableExtCon As Long
Private m_pVTableQIHook As Long

#If DEBUGROT Then
'Debugging object collection.  See ClearROT procedure
'for an explanation
Private m_ObjColl As New Collection
#End If

Public Sub InitROTHook(ROTHook As ROTHook)
    If m_pVTableMain = 0 Then
        If VBoost Is Nothing Then InitVBoost
        'Fill in our identerface identifiers
        IID_IUnknown = IIDFromString(strIID_IUnknown)
        IID_IExternalConnection = IIDFromString(strIID_IExternalConnection)
        IID_IROTHook = IIDFromString(strIID_IROTHook)
        IID_IQIHook = IIDFromString(strIID_IQIHook)
        
        With m_VTables
            .Main(0) = FuncAddr(AddressOf QueryInterface)
            .Main(1) = FuncAddr(AddressOf AddRef)
            .Main(2) = FuncAddr(AddressOf Release)
            .Main(3) = FuncAddr(AddressOf ExposeObject)
            .Main(4) = FuncAddr(AddressOf HideObject)
            .Main(5) = FuncAddr(AddressOf get_Locked)
            .Main(6) = FuncAddr(AddressOf put_Locked)
            .ExtCon(0) = FuncAddr(AddressOf QueryInterfaceExtCon)
            .ExtCon(1) = FuncAddr(AddressOf AddRefExtCon)
            .ExtCon(2) = FuncAddr(AddressOf ReleaseExtCon)
            .ExtCon(3) = FuncAddr(AddressOf AddConnection)
            .ExtCon(4) = FuncAddr(AddressOf ReleaseConnection)
            .QIHook(0) = FuncAddr(AddressOf QueryInterfaceQIHook)
            .QIHook(1) = FuncAddr(AddressOf AddRefReleaseQIHook)
            .QIHook(2) = .QIHook(1)
            .QIHook(3) = FuncAddr(AddressOf QIHook)
            '.QIHook(4) = FuncAddr(AddressOf MapIID) 'Not used, don't bother
            m_pVTableMain = VarPtr(.Main(0))
            m_pVTableExtCon = VarPtr(.ExtCon(0))
            m_pVTableQIHook = VarPtr(.QIHook(0))
        End With
    End If
    With ROTHook.Struct
        .cRefs = 1
        .pVTableMain = m_pVTableMain
        .pVTableQIHook = m_pVTableQIHook
        .pVTableExternal = m_pVTableExtCon
        VBoost.Assign ROTHook.Hook, VarPtr(.pVTableMain)
    End With
End Sub

'Public function to get an object by a non-progid moniker
Public Function GetMonikeredObject(strMoniker As String) As IUnknown
Dim hr As Long
Dim pmk As IMonikerStub
Dim pROT As IRunningObjectTableStub

    hr = CreateItemMoniker("!", strMoniker, pmk)
    If hr = 0 Then
        hr = GetRunningObjectTable(0, pROT)
        If hr = 0 Then
            hr = pROT.GetObject(pmk, GetMonikeredObject)
        End If
    End If
    If hr Then Err.Raise hr
End Function

Private Function QueryInterface(This As IROTHookImpl, riid As VBGUID, pvObj As Long) As Long
Dim fOK As BOOL
    With This
        If .fPassThrough Then
            QueryInterface = .pOuter.QueryInterface(riid, pvObj)
        Else
            Select Case riid.Data1
                Case 0
                    fOK = IsEqualGUID(riid, IID_IUnknown)
                Case &H995811
                    fOK = IsEqualGUID(riid, IID_IROTHook)
                Case &H19
                    If IsEqualGUID(riid, IID_IExternalConnection) Then
                        If .pExternal Is Nothing Then
                            QueryInterface = .pOuter.QueryInterface(riid, pvObj)
                            If QueryInterface = 0 Then
                                .pOuter.Release
                                .fAddRefOuter = True
                                VBoost.Assign .pExternal, pvObj
                            End If
                        End If
                        If QueryInterface = 0 Then
                            .cRefsExternal = .cRefsExternal + 1
                            pvObj = VarPtr(.pVTableExternal)
                            Exit Function
                        End If
                    End If
            End Select
            If fOK Then
                pvObj = VarPtr(.pVTableMain)
                .cRefs = .cRefs + 1
            Else
                pvObj = 0
                QueryInterface = E_NOINTERFACE
            End If
        End If
    End With
End Function
Private Function AddRef(This As IROTHookImpl) As Long
    With This
        .cRefs = .cRefs + 1
        AddRef = .cRefs
    End With
End Function
Private Function Release(This As IROTHookImpl) As Long
    With This
        .cRefs = .cRefs - 1
        Release = .cRefs
        If .cRefs = 0 Then
            If .fAddRefOuter Then
                .pOuter.AddRef
                .fAddRefOuter = False
            End If
            VBoost.AssignZero .pOuter
            Set .UnkHook = Nothing
            'Remove this object from our debug only collection
            #If DEBUGROT Then
            On Error Resume Next
            m_ObjColl.Remove CStr(VarPtr(.pVTableMain))
            On Error GoTo 0 'Clear the error just in case
            #End If
        End If
    End With
End Function
Private Function ExposeObject(This As IROTHookImpl, ByVal pUnk As IUnknown, ByVal ProgID As String, ByVal fProgIDIsMoniker As Boolean, ByVal ServiceSupport As ROTServiceSupport) As Long
Dim CLSID As VBGUID
Dim pmk As IMonikerStub
Dim pROT As IRunningObjectTableStub
Dim pQIHook As IQIHook
    If This.dwRegister Then HideObject This
    If pUnk Is Nothing Then
        Debug.Assert False
        'If this happens, then we're being called incorrectly,
        'Let's return an error instead of GPF'ing on the next call.
        ExposeObject = &H800A005B 'Error 91
    End If
    If fProgIDIsMoniker Then
        ExposeObject = CreateItemMoniker("!", ProgID, pmk)
    Else
        ExposeObject = CLSIDFromProgID(StrPtr(ProgID), CLSID)
        If ExposeObject = 0 And ServiceSupport Then
            'We need a moniker, get one now
            ProgID = String$(38, 0)
            StringFromGUID2 CLSID, ProgID
            ExposeObject = CreateItemMoniker("!", ProgID, pmk)
            fProgIDIsMoniker = True
        End If
    End If
    If ExposeObject Then Exit Function
    'Register object
    'Assign outer pointer without calling AddRef
    VBoost.Assign This.pOuter, pUnk
    If fProgIDIsMoniker Then
        'Use IRunningObjectTable.Register directly
        ExposeObject = GetRunningObjectTable(0, pROT)
        If ExposeObject = 0 Then
            If ServiceSupport Then
                ExposeObject = pROT.Register(ROTFLAGS_ALLOWANYCLIENT, VarPtr(This), pmk, This.dwRegister)
                'Put in a failover case
                If ExposeObject And ServiceSupport = ssAttemptServiceSupport Then
                    ExposeObject = pROT.Register(ROTFLAGS_DEFAULT, VarPtr(This), pmk, This.dwRegister)
                End If
            Else
                ExposeObject = pROT.Register(ROTFLAGS_DEFAULT, VarPtr(This), pmk, This.dwRegister)
            End If
        End If
    Else
        ExposeObject = RegisterActiveObject(VarPtr(This), CLSID, ACTIVEOBJECT_WEAK, This.dwRegister)
    End If
    'Check for harmless success code
    If ExposeObject = MK_S_MONIKERALREADYREGISTERED Then ExposeObject = 0
    If ExposeObject = 0 Then
        This.fPassThrough = True
        'Attempt to hook the unknown
        VBoost.Assign pQIHook, VarPtr(This.pVTableQIHook)
        On Error Resume Next
        VBoost.HookQI pUnk, pQIHook, uhBeforeQI, This.UnkHook
        VBoost.AssignZero pQIHook
        If Err Then
            HideObject This
            ExposeObject = Err
        End If
        On Error GoTo 0
    Else
        If This.fAddRefOuter Then
            This.pOuter.AddRef
            This.fAddRefOuter = False
        End If
        VBoost.AssignZero This.pOuter
    End If
    'Debug only code, allow call to ClearROT to
    'enable normal shutdown.  See comments in ClearROT routine.
    #If DEBUGROT Then
    If ExposeObject = 0 Then
        On Error Resume Next
        m_ObjColl.Add VarPtr(This), CStr(VarPtr(This))
        On Error GoTo 0 'Clear error just in case
    End If
    #End If
End Function
Private Function HideObject(This As IROTHookImpl) As Long
Dim tmpRegister As Long
    With This
        If .dwRegister Then
            'Guarantee that this isn't reentered
            tmpRegister = .dwRegister
            .dwRegister = 0
            If .fLocked Then put_Locked This, False
            .fPassThrough = False
            HideObject = RevokeActiveObject(tmpRegister)
            Set .UnkHook = Nothing
        End If
    End With
End Function
Private Function get_Locked(This As IROTHookImpl, retVal As Boolean) As Long
    retVal = This.fLocked
End Function
Private Function put_Locked(This As IROTHookImpl, ByVal RHS As Boolean) As Long
    With This
        If .fLocked <> RHS Then
            If .dwRegister Or .fLocked Then
                .fLocked = RHS
                .fPassThrough = False
                put_Locked = CoLockObjectExternal(VarPtr(This), -RHS, 1)
                .fPassThrough = True
            Else
                put_Locked = &H800A005B 'Object variable not set
            End If
        End If
    End With
End Function

'IQIHook implementation
Private Function QueryInterfaceQIHook(ByVal This As Long, riid As VBGUID, pvObj As Long) As Long
Dim fOK As BOOL
    Select Case riid.Data1
        Case 0
            fOK = IsEqualGUID(riid, IID_IUnknown)
        Case &H20708EE4
            fOK = IsEqualGUID(riid, IID_IQIHook)
        Case Else
            fOK = BOOL_FALSE
    End Select
    If fOK Then
        pvObj = This
    Else
        pvObj = 0
        QueryInterfaceQIHook = E_NOINTERFACE
    End If
End Function
Private Function AddRefReleaseQIHook(ByVal This As Long) As Long
    'Nothing to do
End Function
Private Function QIHook(This As IQIHookImpl, riid As VBoostTypes.VBGUID, ByVal uhFlags As VBoostTypes.UnkHookFlags, pResult As stdole.IUnknown, ByVal HookedUnknown As stdole.IUnknown) As Long
    If riid.Data1 = &H19 Then
        If IsEqualGUID(riid, IID_IExternalConnection) Then
            With This
                If Not .pExternal Is Nothing Then
                    .cRefsExternal = .cRefsExternal + 1
                    VBoost.Assign pResult, VarPtr(.pVTableExternal)
                End If
            End With
        End If
    End If
End Function

'IExternalConnection implementation
Private Function QueryInterfaceExtCon(This As IExtConImpl, riid As VBGUID, pvObj As Long) As Long
    QueryInterfaceExtCon = This.pExternal.QueryInterface(riid, pvObj)
End Function
Private Function AddRefExtCon(This As IExtConImpl) As Long
    'No need to AddRef the main object.  It's already kept alive
    'by the reference we have on it.
    With This
        .cRefsExternal = .cRefsExternal + 1
        AddRefExtCon = .cRefsExternal
    End With
End Function
Private Function ReleaseExtCon(This As IExtConImpl) As Long
    With This
        .cRefsExternal = .cRefsExternal - 1
        ReleaseExtCon = .cRefsExternal
        If .cRefsExternal = 0 Then
            If .fAddRefOuter Then
                .pOuter.AddRef
                .fAddRefOuter = False
            End If
            Set .pExternal = Nothing
            'Nothing left to hook
            Set .UnkHook = Nothing
        End If
    End With
End Function
Private Function AddConnection(This As IExtConImpl, ByVal extconn As Long, ByVal reserved As Long) As Long
    With This
        AddConnection = .pExternal.AddConnection(extconn, reserved)
        .cConnections = .cConnections + 1
    End With
End Function
Private Function ReleaseConnection(This As IExtConImpl, ByVal extconn As Long, ByVal reserved As Long, ByVal fLastReleaseCloses As Long) As Long
Dim tmpROTHook As IROTHook
    With This
        ReleaseConnection = .pExternal.ReleaseConnection(extconn, reserved, fLastReleaseCloses)
        .cConnections = .cConnections - 1
        If .cConnections = 0 Then
            If .fAddRefOuter Then
                .pOuter.AddRef
                .fAddRefOuter = False
            End If
            'Back up two vtable points (8 bytes) to get at the real object
            VBoost.Assign tmpROTHook, VBoost.UDif(VarPtr(.pVTableExternal), 8)
            tmpROTHook.HideObject
            VBoost.AssignZero tmpROTHook
        End If
    End With
End Function
Private Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
End Function

#If DEBUGROT Then
Public Sub ClearROT()
Dim ROTHook As IROTHook
Dim Var As Variant
Dim pROTHook As Long
    For Each Var In m_ObjColl
        pROTHook = Var
        VBoost.Assign ROTHook, pROTHook
        ROTHook.HideObject
        VBoost.AssignZero ROTHook
    Next
    Set m_ObjColl = Nothing
End Sub
#End If

